home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / doloop / ISTSB.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  28.5 KB  |  821 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.1
  3. C---------------------------------------------------------
  4. C
  5. C    - REMOVE TABS
  6. C    - PROGRAM UNITS RE-ORDERED
  7. C    - ADDITIONAL YADEFS INCLUSIONS REMOVED
  8. C    - DEFINES MOVED
  9. C    - UNSPLIT LINES REMOVED
  10. C    - CHANGE ZCTYPE TO ZPTYPE
  11. C    - USE NEW TOKEN WRITE ROUTINE, CHANGE IODTKO/IODCMO FOR
  12. C      TKNCHN AND USE ZTKPTI AS AN INITIALISATION CALL.
  13. C
  14. C--------   ISTSB.MAC
  15. C---------------------------------------------------------
  16. C    TOOLPACK/1    Release: 2.1
  17. C---------------------------------------------------------
  18. C---------------------------------------------------------
  19. C    TOOLPACK/1    Release: 2.1
  20. C---------------------------------------------------------
  21. C---------------------------------------------------------
  22. C    TOOLPACK/1    Release: 2.1
  23. C---------------------------------------------------------
  24.  
  25.  
  26.  
  27.  
  28.  
  29.  
  30.  
  31.  
  32. C                                   parameter length
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40.  
  41.  
  42. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  43. C
  44.       PROGRAM ISTSB
  45.  
  46.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  47.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  48.  
  49. C---------------------------------------------------------
  50. C    TOOLPACK/1    Release: 2.1
  51. C---------------------------------------------------------
  52. C
  53. C THIS IS USED BY BOTH ISTSB AND ISTCD
  54. C
  55. C This COMMON block contains the logical variable ITERAT which is
  56. C set to .TRUE. when a condition is encountered that implies that
  57. C further processing is required on the parse tree obtained from
  58. C the token stream output from the current run.  ZQUIT is called
  59. C with condition 'repeat' if and only if ITERAT is .TRUE.
  60. C
  61. C This COMMON block contains the logical variables ITERAT and CYCLE.
  62.  
  63.       COMMON /REPEAT/ ITERAT,CYCLE
  64.       LOGICAL ITERAT,CYCLE
  65.  
  66.       INTEGER TKNPTH(81),CIPTH(81),NWARN,NERROR,
  67.      +          TKOPTH(81),CMOPTH(81),CMTPTH(81),JUNK
  68.  
  69.       INTEGER OPEN,CREATE,GETARG,ZYINCI,YPARSE,ZRENAM
  70.       EXTERNAL OPEN,CREATE,ERROR,ZINIT,ZQUIT,ZYINSY,ZYINPT,ZMESS,
  71.      +           GETARG,ZYINCI
  72.       SAVE
  73.         DATA (CIPTH(I),I=1,10)/35,
  74.      +115,98,99,109,105,116,109,112,129/
  75.  
  76.       CALL ZINIT
  77.  
  78.       IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
  79.       IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
  80.       IF (GETARG(3,TKOPTH,81).EQ.-100) CALL NAMES(3,TKOPTH)
  81.       IF (GETARG(4,CMOPTH,81).EQ.-100) CALL NAMES(4,CMOPTH)
  82.  
  83.       IODCMI = CREATE(CIPTH,2)
  84.       IF (IODCMI.EQ.-1) CALL ERROR('Can''t create scratch file.')
  85.  
  86.   100 CONTINUE
  87.       IODTKN=OPEN(TKNPTH,0)
  88.       IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token stream.')
  89.       IODCMT=OPEN(CMTPTH,0)
  90.       IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment file.')
  91.       IODTKO=CREATE(TKOPTH,1)
  92.       IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token stream.')
  93.       IODCMO=CREATE(CMOPTH,1)
  94.       IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment stream.')
  95.  
  96.       CALL INISTR
  97.       CALL INISYM
  98.       CALL INITRE
  99.       NERROR = 0
  100.       NWARN = 0
  101.       IF(YPARSE(IODTKN,IODCMT,-1,IODCMI,NERROR,NWARN).NE.0) CALL
  102.      +   ERROR('[ISTSB - PARSER FATAL ERROR].')
  103.  
  104.       IF(NERROR .GT. 0) CALL ERROR('[ISTSB - PARSER ERRORS REPORTED].')
  105.  
  106.       CALL SEEK(0, IODCMI)
  107.       CALL SEEK(0, IODCMT)
  108.       IF(ZYINCI(IODCMI) .EQ. -1) CALL ERROR('[ISTSB - ZYINCI ERROR].')
  109.  
  110. C Initialize ITERAT in COMMON block REPEAT.
  111.       ITERAT = .FALSE.
  112.  
  113.       CALL PROFIL
  114.  
  115.       IF (ITERAT) THEN
  116. C*** EITHER USE THIS CODE (AUTOMATIC RE-PROCESSING)
  117.          CALL ZMESS('[ ** Repeating ISTSB ** ].',2)
  118.          CALL CLOSE(IODTKN)
  119.          CALL CLOSE(IODCMT)
  120.          CALL CLOSE(IODTKO)
  121.          CALL CLOSE(IODCMO)
  122.          CALL SEEK(0, IODCMI)
  123.          CALL REMOVE(TKNPTH)
  124.          CALL REMOVE(CMTPTH)
  125.          IF(ZRENAM(TKOPTH, TKNPTH) .EQ. -1)
  126.      +     CALL ERROR('[ISTSB - UNABLE TO RENAME TOKEN STREAM].')
  127.          IF(ZRENAM(CMOPTH, CMTPTH) .EQ. -1)
  128.      +     CALL ERROR('[ISTSB - UNABLE TO RENAME COMMENT STREAM].')
  129.          GO TO 100
  130. C*** OR THIS CODE (SINGLE OPERATION ONLY)
  131. C*                 CALL ZMESS('[ISTSB Normal Termination].',stderr)
  132. C*                 CALL ZMESS('[ ** Repeat ISTSB ** ].',stderr)
  133. C*                 CALL ZQUIT(termflag_0)
  134. C*** END-OF-SELECTION
  135.  
  136.       ELSE
  137.          CALL CLOSE(IODCMI)
  138.          CALL REMOVE(CIPTH)
  139.          CALL ZMESS('[ISTSB Normal Termination].',2)
  140.          CALL ZQUIT(-2)
  141.       END IF
  142.  
  143.       END
  144. C ----------------------------------------------------------------------
  145. C
  146.       SUBROUTINE NAMES (NUMBER,PATH)
  147.  
  148.       INTEGER NUMBER,PATH(81)
  149.  
  150.       INTEGER ZGTCMD
  151.       EXTERNAL ZGTCMD,ZPRMPT
  152.  
  153.       INTEGER JUNK,PROMPT(24,4)
  154.  
  155.       SAVE PROMPT
  156.  
  157. C "Input token stream:"
  158. C "Input comment stream: "
  159. C "Output token stream: "
  160. C "Output comment stream: "
  161.  
  162.       DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
  163.      +111,107,101,110,32,115,116,114,101,97,109,
  164.      +58,32,129/,
  165.      +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
  166.      +111,109,109,101,110,116,32,115,116,114,101,97,109,
  167.      +58,32,129/,
  168.      +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
  169.      +116,111,107,101,110,32,115,116,114,101,97,109,
  170.      +58,32,129/,
  171.      +       (PROMPT(I,4),I=1,24)/79,117,116,112,117,116,32,
  172.      +99,111,109,109,101,110,116,32,115,116,114,101,97,
  173.      +109,58,32,129/
  174.  
  175.       CALL ZPRMPT(PROMPT(1,NUMBER))
  176.       JUNK=ZGTCMD(PATH,0)
  177.  
  178.       END
  179. C ----------------------------------------------------------------------
  180. C
  181. C       P R O F I L   -   Process files
  182. C
  183.  
  184.       SUBROUTINE PROFIL
  185.  
  186.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  187.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  188.  
  189. C---------------------------------------------------------
  190. C    TOOLPACK/1    Release: 2.1
  191. C---------------------------------------------------------
  192. C
  193. C  TKLAST = LAST TOKEN NUMBER
  194. C
  195.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  196.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  197.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  198.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  199.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  200.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  201.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  202.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  203.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  204.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  205.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  206.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  207.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  208.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  209.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  210.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  211.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  212.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  213.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  214.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  215.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  216.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  217.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  218.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  219.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  220.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  221.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  222.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  223.  
  224. C---------------------------------------------------------
  225. C    TOOLPACK/1    Release: 2.1
  226. C---------------------------------------------------------
  227. C
  228. C THIS IS USED BY BOTH ISTSB AND ISTCD
  229. C
  230. C This COMMON block contains the logical variable ITERAT which is
  231. C set to .TRUE. when a condition is encountered that implies that
  232. C further processing is required on the parse tree obtained from
  233. C the token stream output from the current run.  ZQUIT is called
  234. C with condition 'repeat' if and only if ITERAT is .TRUE.
  235. C
  236. C This COMMON block contains the logical variables ITERAT and CYCLE.
  237.  
  238.       COMMON /REPEAT/ ITERAT,CYCLE
  239.       LOGICAL ITERAT,CYCLE
  240.  
  241.       INTEGER TEXT(134), SYMVAL(8)
  242.       INTEGER ZYDOWN,ZYNEXT,ZYROOT,ZTKPTI,ZYGPUS
  243.       COMMON /CLAB/ CURLBL,CURPUN,FIRST
  244.       LOGICAL FIRST, FLAG
  245.       INTEGER CURLBL,CURPUN,SNUM
  246.  
  247.       SAVE
  248.  
  249.       INTEGER PTR
  250.  
  251.       TKNCHN = ZTKPTI(1, IODTKO, IODCMO)
  252.       IF(TKNCHN .EQ. -1) CALL ERROR('[ISTSB - Output Stream Failure].')
  253.       CURPUN = 0
  254.       PTR=ZYDOWN(ZYROOT())
  255.  
  256.       FLAG = .FALSE.
  257.       SNUM = 1
  258.  
  259.  100  IF (PTR.GT.0) THEN
  260.          CURLBL = 39999
  261.          CURPUN = CURPUN + 1
  262.          FIRST = .TRUE.
  263.          CALL ZYGTSY(ZYGPUS(CURPUN), SYMVAL)
  264.          CALL ZYGTST(SYMVAL(2), TEXT)
  265.          CALL ZCHOUT('SB Processing: ', 2)
  266.          CALL ZPTMES(TEXT, 2)
  267.          CALL PROPU(FLAG, SNUM, PTR)
  268.          PTR=ZYNEXT(PTR)
  269.          GO TO 100
  270.       END IF
  271.  
  272.       CALL ZTOKWR(TZEOF,0,TEXT,TKNCHN)
  273.       CALL ZTKPTQ(TKNCHN)
  274.  
  275.       END
  276. C--------   PROPU.MAC
  277. C
  278. C       P R O P U   -   Process Program-Unit
  279. C
  280.  
  281.       SUBROUTINE PROPU(ASGN, SNUM,PUROOT)
  282.       LOGICAL ASGN
  283.       INTEGER PUROOT, SNUM
  284.  
  285.       INTEGER SPTR,NUMIN,NUMOUT,SEQLST(2000),SEQNR,
  286.      +        TYPE,OKNO,POS1(30),POS2(30),
  287.      +        POS3(30),NRNAMS,NAMES(7,30),I
  288.  
  289.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  290.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  291.  
  292.       INTEGER ZYDOWN,ZYNEXT,NODETP,CONSUB
  293.       EXTERNAL ZYDOWN,ZYNEXT,NODETP,YSTMT,COMOUT,PROSEQ,CONSUB
  294.  
  295.  
  296. C---------------------------------------------------------
  297. C    TOOLPACK/1    Release: 2.1
  298. C---------------------------------------------------------
  299. C
  300. C  TKLAST = LAST TOKEN NUMBER
  301. C
  302.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  303.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  304.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  305.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  306.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  307.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  308.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  309.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  310.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  311.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  312.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  313.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  314.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  315.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  316.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  317.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  318.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  319.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  320.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  321.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  322.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  323.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  324.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  325.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  326.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  327.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  328.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  329.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  330.  
  331. C---------------------------------------------------------
  332. C    TOOLPACK/1    Release: 2.1
  333. C---------------------------------------------------------
  334. C
  335. C THIS IS USED BY BOTH ISTSB AND ISTCD
  336. C
  337. C This COMMON block contains the logical variable ITERAT which is
  338. C set to .TRUE. when a condition is encountered that implies that
  339. C further processing is required on the parse tree obtained from
  340. C the token stream output from the current run.  ZQUIT is called
  341. C with condition 'repeat' if and only if ITERAT is .TRUE.
  342. C
  343. C This COMMON block contains the logical variables ITERAT and CYCLE.
  344.  
  345.       COMMON /REPEAT/ ITERAT,CYCLE
  346.       LOGICAL ITERAT,CYCLE
  347.       SAVE
  348.  
  349.       NRNAMS = 0
  350.       DO 10 I = 1, 30
  351.          POS1(I) = 3
  352.          POS2(I) = 3
  353.          POS3(I) = 3
  354.    10 CONTINUE
  355.  
  356.       SPTR=ZYDOWN(PUROOT)
  357.  
  358.   100 CONTINUE
  359.       TYPE = NODETP(SPTR)
  360. C Assignment statements for which 'no' is returned by CONSUB count as
  361. C non-assignment statements for the purpose of determining the end of an
  362. C assignment sequence.  However, an attempt will be made to start a new
  363. C assignment sequence with such an assignment statement.
  364.  
  365.       IF (TYPE .EQ. 49) OKNO = CONSUB(SPTR,NAMES,POS1,POS2,
  366.      +                                      POS3,NRNAMS)
  367.  
  368.       IF ((TYPE .NE. 49) .OR. (OKNO .EQ. -3)) THEN
  369. C If this is the first non-assignment statement (or failure of the
  370. C conditions tested by CONSUB) after an assignment sequence, process the
  371. C assignment sequence.
  372.  
  373.          IF (ASGN) THEN
  374.             CALL PROSEQ(SEQLST,SEQNR,NUMIN,NUMOUT)
  375. C NUMOUT (output) is the number of the last statement in the sequence.
  376.             SNUM = NUMOUT
  377.             ASGN = .FALSE.
  378. C Reinitialize the POSn, n=1,2,3 and NRNAMS.
  379.             NRNAMS = 0
  380.             DO 20 I = 1,30
  381.                POS1(I) = 3
  382.                POS2(I) = 3
  383.                POS3(I) = 3
  384. 20            CONTINUE
  385.          END IF
  386. C If a failure of CONSUB was encountered, the offending assignment
  387. C statement is not immediately output but first an attempt is made to
  388. C start a new assignment sequence.
  389.  
  390.          IF (TYPE .NE. 49) THEN
  391.               CALL YSTMT(SPTR,TKNCHN)
  392.               SNUM=SNUM+1
  393.             CALL COMOUT(SNUM)
  394.          ELSE
  395.             NRNAMS = 0
  396.             DO 30 I = 1,30
  397.                POS1(I) = 3
  398.                POS2(I) = 3
  399.                POS3(I) = 3
  400. 30            CONTINUE
  401.             IF (CONSUB(SPTR,NAMES,POS1,POS2,POS3,NRNAMS) .EQ. -2) THEN
  402.                SEQNR = 1
  403.                ASGN = .TRUE.
  404. C NUMIN is the number of the first statement in the sequence.
  405.                NUMIN = SNUM
  406.                SEQLST(SEQNR) = SPTR
  407.             ELSE
  408.                  CALL YSTMT(SPTR,TKNCHN)
  409.                  SNUM=SNUM+1
  410.                CALL COMOUT(SNUM)
  411.             END IF
  412.          END IF
  413.       ELSE
  414. C Statement is an assignment statement for which CONSUB returns 'ok'.
  415. C If this is the first such assignment statement start an assignment
  416. C sequence; otherwise, add the node to the active assignment sequence.
  417.  
  418.          IF (.NOT. ASGN) THEN
  419.             SEQNR = 0
  420.             ASGN = .TRUE.
  421. C NUMIN is the number of the first statement in the sequence.
  422.             NUMIN = SNUM
  423.          END IF
  424. C Add statement node to assignment sequence.
  425.          SEQNR = SEQNR + 1
  426.          SEQLST(SEQNR) = SPTR
  427.       END IF
  428.  
  429.       SPTR=ZYNEXT(SPTR)
  430.       IF (SPTR.NE.0) GOTO 100
  431.  
  432.       END
  433. C--------   CONSUB.MAC
  434.       INTEGER FUNCTION CONSUB(NODE,NAMES,POS1,POS2,POS3,NRNAMS)
  435.  
  436.       INTEGER NODE,NAMES(7,30),POS1(30),
  437.      +          POS2(30),POS3(30),NRNAMS
  438.  
  439. C NRNAMS is the number of entries in the list NAMES of names of array
  440. C elements.  POS1,POS2,POS3 contain, in the entry corresponding to an
  441. C array name, either 'constant', 'variable', or 'nodim' according to
  442. C whether the 1st, 2nd, and 3rd subscript positions for that array are
  443. C constant, variable, or do not exist.  NOTE!! POS1, POS2, and POS3 MUST
  444. C be initialized to 'nodim' and NRNAMS to 0 before the first call of
  445. C CONSUB for each sequence of assignment statements.
  446.  
  447. C Given the assignment statement rooted at NODE, search for array
  448. C elements on either side.  When one is found, determine whether its name
  449. C is on the list NAMES.
  450. C
  451. C When an array element is found whose name is not on the list, add its
  452. C name to the list, together with appropriate entries in POS1, POS2, and
  453. C POS3.  Set CONSUB to 'ok' and continue.  If an entry with more than
  454. C three dimensions is encountered, set CONSUB to 'no' and return.
  455. C
  456. C When an array element is found whose name is on the list, determine
  457. C whether the each subscript is constant or variable as recorded.  If
  458. C such is the case, set CONSUB to 'ok' and continue.  If some subscript
  459. C is different, set CONSUB to 'no' and return.
  460. C
  461. C Thus, CONSUB returns 'no' if it discovers an array element with a
  462. C subscript that is constant in one place and variable in another or vice
  463. C versa, or if it discovers an array element with more than three
  464. C dimensions.  Otherwise, CONSUB updates the lists and returns 'ok'.
  465.  
  466.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  467.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  468.  
  469.       INTEGER POINTR,STACK(500),SUBPTR,ARNAME(7),
  470.      +          NAMPTR,P1,P2,P3, I
  471.  
  472.       INTEGER NODETP,ZYDOWN,ZYNEXT,PUSH,POP,EQUAL
  473.       EXTERNAL NODETP,ZYDOWN,ZYNEXT,PUSH,POP,EQUAL
  474.  
  475.       STACK(1) = -1
  476.  
  477.       IF (NODETP(NODE) .NE. 49) CALL ERROR('ISTSB: Input'
  478.      +      //'Node Not An Assignment Statement.')
  479.  
  480.       POINTR = ZYDOWN(NODE)
  481. 30      CONTINUE
  482.       IF(PUSH(POINTR,STACK) .EQ. -1)CALL ERROR('ISTSB: Stack Full.')
  483.       IF (NODETP(POINTR) .EQ. 104) THEN
  484. C Node is an array element.  Is its name on the list?
  485.          NAMPTR = ZYDOWN(POINTR)
  486.          CALL GETSTR(NAMPTR,ARNAME)
  487.          DO 10 I = 1,NRNAMS
  488.             IF (EQUAL(ARNAME,NAMES(1,I)) .EQ. -2) GO TO 20
  489. 10         CONTINUE
  490. C Name is not on the list, enter it.
  491.          NRNAMS = NRNAMS + 1
  492.          CALL SCOPY(ARNAME,1,NAMES(1,NRNAMS),1)
  493. C Determine the entries for the subscripts and enter them.
  494.          SUBPTR = ZYNEXT(NAMPTR)
  495.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  496.             POS1(NRNAMS) = 0
  497.          ELSE
  498.             POS1(NRNAMS) = 1
  499.          END IF
  500.          SUBPTR = ZYNEXT(SUBPTR)
  501.          IF (SUBPTR .EQ. 0) THEN
  502.             CONSUB = -2
  503.             GO TO 60
  504.          END IF
  505.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  506.             POS2(NRNAMS) = 0
  507.          ELSE
  508.             POS2(NRNAMS) = 1
  509.          END IF
  510.          SUBPTR = ZYNEXT(SUBPTR)
  511.          IF (SUBPTR .EQ. 0) THEN
  512.             CONSUB = -2
  513.             GO TO 60
  514.          END IF
  515.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  516.             POS3(NRNAMS) = 0
  517.          ELSE
  518.             POS3(NRNAMS) = 1
  519.          END IF
  520.          SUBPTR = ZYNEXT(SUBPTR)
  521.          IF (SUBPTR .NE. 0) THEN
  522.          CALL REMARK('CONSUB: Array Element With More Than'//
  523.      +                  ' Three Dimensions.')
  524.             CONSUB = -3
  525.             RETURN
  526.          END IF
  527. 20         CONTINUE
  528. C Name of array element is on the list.  Check consistency of
  529. C new appearance with information on list.
  530.          P1 = 3
  531.          P2 = 3
  532.          P3 = 3
  533.          SUBPTR = ZYNEXT(NAMPTR)
  534.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  535.             P1 = 0
  536.          ELSE
  537.             P1 = 1
  538.          END IF
  539.          SUBPTR = ZYNEXT(SUBPTR)
  540.          IF (SUBPTR .EQ. 0) GO TO 50
  541.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  542.             P2 = 0
  543.          ELSE
  544.             P2 = 1
  545.          END IF
  546.          SUBPTR = ZYNEXT(SUBPTR)
  547.          IF (SUBPTR .EQ. 0) GO TO 50
  548.          IF (NODETP(SUBPTR) .EQ. 107) THEN
  549.             P3 = 0
  550.          ELSE
  551.             P3 = 1
  552.          END IF
  553. 50         CONTINUE
  554.          IF ((POS1(I) .NE. P1) .OR. (POS2(I) .NE. P2) .OR.
  555.      +         (POS3(I) .NE. P3)) THEN
  556.             CONSUB = -3
  557.             RETURN
  558.          ELSE
  559.             CONSUB = -2
  560.          END IF
  561.       END IF
  562. 60      CONTINUE
  563.       POINTR = ZYDOWN(POINTR)
  564. C If POINTR > 0, node is not a leaf. If POINTR = 0, node is an unnamed
  565. C leaf.
  566.       IF (POINTR .GT. 0) GO TO 30
  567. C Node is a leaf.
  568.       POINTR = POP(STACK)
  569. C Can't go down; try next unless we have finished.
  570.       IF(POINTR .EQ. NODE) THEN
  571.          CONSUB = -2
  572.          RETURN
  573.       END IF
  574.       POINTR = ZYNEXT(POINTR)
  575.       IF(POINTR .GT. 0) GO TO 30
  576.  
  577. C Can't go next, pop until next is possible or return to NODE is complete.
  578.         POINTR = POP(STACK)
  579.       IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  580.          CONSUB = -2
  581.          RETURN
  582.       END IF
  583. 40      CONTINUE
  584.       POINTR = ZYNEXT(POINTR)
  585.       IF(POINTR .GT. 0) THEN
  586.          GO TO 30
  587.       ELSE
  588.          POINTR = POP(STACK)
  589.          IF(POINTR .EQ. -1 .OR. POINTR .EQ. NODE) THEN
  590.             CONSUB = -2
  591.             RETURN
  592.          END IF
  593.          GO TO 40
  594.       END IF
  595.  
  596.       END
  597. C--------   PROSEQ.MAC
  598. C -------------------------------------------------------------------
  599. C      P R O S E Q - Process Assignment Sequence
  600. C
  601.       SUBROUTINE PROSEQ(LIST,NR,NUMF,NUML)
  602. C Process the assignment sequence whose nodes are on LIST.
  603. C There are NR statements in the sequence.  The first has statement
  604. C number NUMF in the program unit.  The last has statement number
  605. C NUML, which is output from PROSEQ.
  606.  
  607.       INTEGER LIST(*),NR,NUMF,NUML
  608.  
  609.       INTEGER LHSNOD,LPTR,NPTR,NXTNOD,SNUM,RHSNOD,I,COM1(66),
  610.      +          DNODES(200),NRDEPS,DSET1(200),NRSET1,DSET2(200),
  611.      +          NRSET2,TRYNOD,BUFFER,APTR,LALHS,COM2(28), J
  612.  
  613.       COMMON/IO/ IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  614.       INTEGER IODTKN,IODCMI,IODCMT,IODTKO,IODCMO,TKNCHN
  615.  
  616. C---------------------------------------------------------
  617. C    TOOLPACK/1    Release: 2.1
  618. C---------------------------------------------------------
  619. C
  620. C  TKLAST = LAST TOKEN NUMBER
  621. C
  622.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  623.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  624.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  625.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  626.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  627.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  628.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  629.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  630.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  631.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  632.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  633.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  634.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  635.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  636.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  637.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  638.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  639.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  640.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  641.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  642.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  643.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  644.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  645.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  646.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  647.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  648.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  649.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  650.  
  651. C---------------------------------------------------------
  652. C    TOOLPACK/1    Release: 2.1
  653. C---------------------------------------------------------
  654. C
  655. C THIS IS USED BY BOTH ISTSB AND ISTCD
  656. C
  657. C This COMMON block contains the logical variable ITERAT which is
  658. C set to .TRUE. when a condition is encountered that implies that
  659. C further processing is required on the parse tree obtained from
  660. C the token stream output from the current run.  ZQUIT is called
  661. C with condition 'repeat' if and only if ITERAT is .TRUE.
  662. C
  663. C This COMMON block contains the logical variables ITERAT and CYCLE.
  664.  
  665.       COMMON /REPEAT/ ITERAT,CYCLE
  666.       LOGICAL ITERAT,CYCLE
  667.  
  668.       INTEGER ZYDOWN,NODETP,ZYNEXT,COMPAR,LENGTH
  669.       EXTERNAL ZYDOWN,NODETP,ZYNEXT,COMPAR,COMOUT,YSTMT,YSTMTS,
  670.      +           DEPSET,LENGTH
  671.  
  672.       SAVE
  673.  
  674. C "C*** Redefinition detected - substitution/elimination applied ***"
  675.       DATA COM1/67,42,42,42,32,82,101,100,101,
  676.      +            102,105,110,105,116,105,111,110,32,
  677.      +            100,101,116,101,99,116,101,100,32,
  678.      +            45,32,115,117,98,115,116,105,116,
  679.      +            117,116,105,111,110,47,101,108,105,
  680.      +            109,105,110,97,116,105,111,110,32,
  681.      +            97,112,112,108,105,101,100,32,42,
  682.      +            42,42,129/
  683.  
  684. C "C*** Statement permuted ***"
  685.       DATA COM2/67,42,42,42,32,83,116,97,116,
  686.      +            101,109,101,110,116,32,112,101,114,
  687.      +            109,117,116,101,100,32,42,42,42,129/
  688.  
  689.       NPTR = 1
  690.       LPTR = 1
  691.       SNUM = NUMF
  692. 400      CONTINUE
  693. C Candidate for redefinition is LIST(NPTR).
  694. C Find its dependency set.
  695.       CALL DEPSET(LIST(NPTR),DNODES,NRDEPS)
  696. C Get node of lhs of candidate for redefinition.
  697.          LHSNOD = ZYDOWN(LIST(NPTR))
  698.       IF (NODETP(LHSNOD) .EQ. 115) LHSNOD = ZYNEXT(LHSNOD)
  699.  
  700. C Process the sequence following LHSNOD.
  701. 100      CONTINUE
  702.       LPTR = LPTR + 1
  703. C Are we finished with the sequence following LHSNOD?
  704.       IF (LPTR .GT. NR) GO TO 1500
  705.  
  706. 900      CONTINUE
  707. C LIST(LPTR) is the current statement in the sequence following the
  708. C candidate for redefinition.
  709.       NXTNOD = ZYDOWN(LIST(LPTR))
  710.       IF (NODETP(NXTNOD) .EQ. 115) NXTNOD = ZYNEXT(NXTNOD)
  711.  
  712. C Test whether LIST(LPTR) is a redefinition.
  713.       IF (COMPAR(NXTNOD,LHSNOD) .EQ. -2) THEN
  714. C Redefinition found.  Output comment that transformation being applied
  715. C and set flag to repeat ISTSB.
  716.  
  717.          CALL ZTOKWR(TCMMNT,LENGTH(COM1),COM1,TKNCHN)
  718.          ITERAT = .TRUE.
  719.  
  720. C Output statements from LIST(NPTR+1) to LIST(LPTR),
  721. C with substitution of rhs of LIST(NPTR).
  722.          RHSNOD = ZYNEXT(LHSNOD)
  723.          DO 200 I = NPTR+1,LPTR
  724.             CALL YSTMTS(LIST(I),LHSNOD,RHSNOD,TKNCHN)
  725.             SNUM = SNUM + 1
  726.             CALL COMOUT(SNUM)
  727. 200         CONTINUE
  728. C Redefined statement not output - adjust comment pointer.
  729.          SNUM = SNUM + 1
  730. C Statement following LIST(LPTR) is new candidate for redefinition,
  731. C unless we are at the end of the sequence.
  732.          NPTR = LPTR + 1
  733.          GO TO 1600
  734.       END IF
  735. C LIST(LPTR) is not a redefinition.  Determine whether it is an
  736. C assignment to one of the names in the dependency set of LIST(NPTR).
  737.  
  738.       DO 500 I=1,NRDEPS
  739.          IF (COMPAR(NXTNOD,DNODES(I)) .EQ. -2) GO TO 1200
  740. 500      CONTINUE
  741. C LIST(LPTR) is not an assignment to a member of the dependency
  742. C set of LIST(NPTR).
  743.       GO TO 100
  744. 1200      CONTINUE
  745. C LIST(LPTR) is an assignment to a member of the dependency set.  Look
  746. C ahead in the assignment sequence for a redefinition.  If one is found,
  747. C attempt to permute it upwards to immediately before LIST(LPTR).
  748.  
  749. C LIST(APTR) is the current statement in the look-ahead.
  750.  
  751.       APTR = LPTR + 1
  752. 1000      CONTINUE
  753. C If we have exhausted the sequence looking for a redefinition,
  754. C advance to the next candidate.
  755.       IF (APTR .GT. NR) GO TO 1500
  756.  
  757. C Is LIST(APTR) a redefinition?
  758.       LALHS = ZYDOWN(LIST(APTR))
  759.       IF (NODETP(LALHS) .EQ. 115) LALHS = ZYNEXT(LALHS)
  760.       IF (COMPAR(LALHS,LHSNOD) .NE. -2) THEN
  761. C LIST(APTR) is not a redefinition.  Continue the search.
  762.          APTR = APTR + 1
  763.          GO TO 1000
  764.       ELSE
  765. C The look-ahead has found a redefinition.  See if it can be
  766. C permuted upwards.
  767.  
  768.          CALL DEPSET(LIST(APTR),DSET1,NRSET1)
  769.  
  770.          DO 1400 I = LPTR,APTR-1
  771. C Is the lhs of LIST(APTR) in the dependency set of LIST(I)?
  772. C If so, proceed to the next candidate for redefinition.
  773.             CALL DEPSET(LIST(I),DSET2,NRSET2)
  774.             DO 700 J = 1,NRSET2
  775.                IF (COMPAR(LALHS,DSET2(J)) .EQ. -2) GO TO 1500
  776. 700            CONTINUE
  777.  
  778. C Is the lhs of LIST(I) in the dependency set of LIST(APTR)?
  779. C If so, proceed to the next candidate for redefinition.
  780.             TRYNOD = ZYDOWN(LIST(I))
  781.             IF (NODETP(TRYNOD) .EQ. 115) TRYNOD = ZYNEXT(TRYNOD)
  782.             DO 800 J = 1,NRSET1
  783.                IF (COMPAR(TRYNOD,DSET1(J)) .EQ. -2) GO TO 1500
  784. 800            CONTINUE
  785. 1400         CONTINUE
  786.  
  787. C Permute LIST(APTR) to immediately before the current LIST(LPTR).
  788.          BUFFER = LIST(APTR)
  789.          DO 1100 I = APTR-1,LPTR,-1
  790.             LIST(I+1) = LIST(I)
  791. 1100         CONTINUE
  792.          LIST(LPTR) = BUFFER
  793.          CALL ZTOKWR(TCMMNT,LENGTH(COM2),COM2,TKNCHN)
  794.          GO TO 900
  795.       END IF
  796.  
  797. 1500      CONTINUE
  798. C No redefinition possible, output candidate.
  799.          CALL YSTMT(LIST(NPTR),TKNCHN)
  800.          SNUM = SNUM + 1
  801.          CALL COMOUT(SNUM)
  802. C Statement after candidate is new candidate for redefinition
  803. C unless we are at end of sequence.
  804.          NPTR = NPTR + 1
  805. 1600         CONTINUE
  806.          IF (NPTR .GT. NR) THEN
  807.             NUML = SNUM
  808.             RETURN
  809.          ELSE IF (NPTR .EQ. NR) THEN
  810.             CALL YSTMT(LIST(NPTR),TKNCHN)
  811.             SNUM = SNUM + 1
  812.             CALL COMOUT(SNUM)
  813.             NUML = SNUM
  814.             RETURN
  815.          ELSE
  816.             LPTR = NPTR
  817.             GO TO 400
  818.          END IF
  819.  
  820.       END
  821.